home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / prog_d / isamexpt.zip / ISAM2DBF.PAS < prev    next >
Pascal/Delphi Source File  |  1996-01-13  |  5KB  |  159 lines
  1. unit Isam2dbf;
  2.  
  3. interface
  4.  
  5. uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  6.   StdCtrls, Isamtabl, Gauges, DB, DBTables, ExtCtrls,
  7.   U_DbTool, Grids, DBGrids;
  8.  
  9. type
  10.   DBASEExportProc = Procedure(var DATA; DBTable: TTable; ISTable: TIsamTable);
  11.  
  12.   TTransferDlg = class(TForm)
  13.     CancelBtn: TBitBtn;
  14.     Bevel1: TBevel;
  15.     Table1: TTable;
  16.     Gauge1: TGauge;
  17.     IsamTable1: TIsamTable;
  18.     StartBttn: TBitBtn;
  19.     DataSource1: TDataSource;
  20.     DBGrid1: TDBGrid;
  21.     procedure FormDestroy(Sender: TObject);
  22.     procedure FormCreate(Sender: TObject);
  23.     procedure FormShow(Sender: TObject);
  24.     procedure StartBttnClick(Sender: TObject);
  25.   private
  26.     { Private declarations }
  27.   public
  28.     StruGetProc : Structure_GetProc;
  29.     FieldGetProc: DBASEExportProc;
  30.     Data,Dup    : Pointer;
  31.   end;
  32.  
  33. var
  34.   TransferDlg: TTransferDlg;
  35.  
  36. Procedure Isam2DBase(aParent: TForm;
  37.                      IsamTable: TIsamTable;
  38.                      DBASETableName: String;
  39.                      Stru_Get: Structure_GetProc;
  40.                      FieldGet: DBASEExportProc);
  41.  
  42. implementation
  43.  
  44. Uses SysUtils, UToolDll, Filer;
  45.  
  46. {$R *.DFM}
  47.  
  48. Procedure Isam2DBase(aParent: TForm;
  49.                      IsamTable: TIsamTable;
  50.                      DBASETableName: String;
  51.                      Stru_Get: Structure_GetProc;
  52.                      FieldGet: DBASEExportProc);
  53. var AktDir: String;
  54. begin
  55.   if Pos('.',DBaseTableName) > 0 then DBaseTableName:= Copy(DBaseTableName,1,Pos('.',DBaseTableName)-1);
  56.   DBaseTableName:= DBaseTableName + '.DBF';
  57.   AktDir:= ExtractFilePath(Application.ExeName);
  58.   Check_Alias('TEST2',AktDir);
  59.   TransferDlg:= TTransferDlg.Create(aParent);
  60.   Try
  61.     TransferDlg.IsamTable1:= IsamTable;
  62.     TransferDlg.Table1.TableName:= DBaseTableName;
  63.     TransferDlg.StruGetProc:= Stru_Get;
  64.     TransferDlg.FieldGetProc:= FieldGet;
  65.     TransferDlg.ShowModal;
  66.   Finally
  67.     TransferDlg.Free;
  68.   end;
  69. end;
  70.  
  71. procedure TTransferDlg.FormDestroy(Sender: TObject);
  72. begin
  73.   FreeMem(Data,IsamTable1.RecSize);
  74.   FreeMem(Dup,IsamTable1.RecSize);
  75.   if Table1.Active then Table1.Close;
  76. end;
  77.  
  78. procedure TTransferDlg.FormCreate(Sender: TObject);
  79. begin
  80.   Table1.DatabaseName:= 'TEST2';
  81.   StruGetProc:= NIL;
  82.   FieldGetProc:= NIL;
  83.   if Sprache = 1 then CancelBtn.Caption:= 'End';
  84. end;
  85.  
  86. procedure TTransferDlg.FormShow(Sender: TObject);
  87. begin
  88.   Erzeuge_Tabelle(Self,
  89.                   Table1.DataBase,
  90.                   Table1.TableName,
  91.                   StruGetProc);
  92.   Table1.Open;
  93.   if Table1.Active then begin
  94.     if Table1.RecordCount > 0 then begin
  95.       if Sprache = 1 then begin
  96.         if JaNein('DBASE-Tabelle already contains data','delete data ?') then begin
  97.           Table1.Close;
  98.           Table1.EmptyTable;
  99.           Table1.Open;
  100.         end;
  101.       end
  102.       else begin
  103.         if JaNein('DBASE-Tabelle enthΣlt bereits Daten','Daten l÷schen ?') then begin
  104.           Table1.Close;
  105.           Table1.EmptyTable;
  106.           Table1.Open;
  107.         end;
  108.       end;
  109.     end;
  110.   end
  111.   else begin
  112.     if Sprache = 1 then Errorwindow('Table could not be opened','')
  113.     else Errorwindow('Tabelle konnte nicht erzeugt werden','');
  114.   end;
  115.   GetMem(Data,IsamTable1.RecSize);
  116.   GetMem(Dup,IsamTable1.RecSize);
  117. end;
  118.  
  119. procedure TTransferDlg.StartBttnClick(Sender: TObject);
  120. var i,RCount: Longint;
  121.     Altprogress,NeuProgress: Integer;
  122. begin
  123.   if Table1.Active then begin
  124.     if IsamTable1.Active then begin
  125.       RCount:= IsamTAble1.RecordCount;
  126.       IsamTable1.First(DATA^,DUP^);
  127.       i:= 0;
  128.       AltProgress:= 0;
  129.       DBGrid1.Hide;
  130.       Repeat
  131.         IsamTable1.Get(DATA^,DUP^);
  132.         if IsamOk then begin
  133.           Table1.Append;
  134.           FieldGetProc(DATA^,Table1,IsamTable1);
  135.           Table1.Post;
  136.           IsamTable1.Next(DATA^,DUP^);
  137.         end;
  138.         Inc(i);
  139.         NeuProgress:= Round((i/RCount)*100);
  140.         if AltProgress <> NeuProgress then begin
  141.           AltProgress:= NeuProgress;
  142.           Gauge1.Progress:= NeuProgress;
  143.         end;
  144.       Until (IsamOk = False) or (i = rCount);
  145.       DbGrid1.Show;
  146.     end
  147.     else begin
  148.       if Sprache = 1 then Errorwindow('Isamtable is not opened','')
  149.       else Errorwindow('Isamtabelle ist nicht ge÷ffnet','');
  150.     end;
  151.   end
  152.   else begin
  153.     if Sprache = 1 then Errorwindow('DBASE-table is not opened','')
  154.     else Errorwindow('DBASE-Tabelle ist nicht ge÷ffnet','');
  155.   end;
  156. end;
  157.  
  158. end.
  159.